home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / front_end / simpfy_call.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  7.4 KB  |  189 lines
  1. (herald (front_end simplify_call)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;;                 Simplifying Call-nodes
  28. ;;;===========================================================================
  29. ;;; Simplify the node in the car of NODE-PAIR.  Trys a series of simplification
  30. ;;; procedures, going back to the beginning whenever a change is made.  The 
  31. ;;; simplifiers are only allowed to change the node and its descendents.  No
  32. ;;; changes may be made to any other part of the tree.
  33.  
  34. (define (simplify-call lambda-node)
  35.   (let ((node (lambda-body lambda-node)))
  36.     (cond ((node-simplified? node)
  37.            node)
  38.           (else
  39.            (iterate loop ((node node))
  40.              (let ((proc (call-proc node)))
  41.                (cond ((and (lambda-node? proc)
  42.                            (simplify-let proc node))
  43.                       (loop (lambda-body lambda-node)))
  44.                      ((and (reference-node? proc)
  45.                            (integrate-definition proc))
  46.                       (loop (lambda-body lambda-node)))
  47.                      ((simplify-call-ignoring-exits node proc)
  48.                       (loop (lambda-body lambda-node)))
  49.                      ((simplify-call-using-exits node)
  50.                       (loop (lambda-body lambda-node)))
  51.                      (else nil))))))))
  52.  
  53. ;;; Simplify the non-exit arguments of NODE and NODE itself.  Returns T if any
  54. ;;; change is made.
  55.  
  56. (define (simplify-call-ignoring-exits node proc)
  57.   (set (node-simplified? proc) t) ; Nothing to do here anyway
  58.   (simplify-non-exit-args node)
  59.   (set (node-simplified? node) t)
  60.   (or (simplify-call-using-proc proc node)
  61.       (not (node-simplified? node))))
  62.  
  63. ;;; Simplify the exits of NODE.  Remove it if has no side effects and its value
  64. ;;; is not used.
  65.  
  66. (define (simplify-call-using-exits node)
  67.   (simplify-exit-args node)
  68.   (or (flush-unused-call node)
  69.       (not (node-simplified? node))))
  70.  
  71. ;;; Simplify the specified children.  These use the NODE-SIMPLIFIED? flag
  72. ;;; to determine if a change has been made.
  73.  
  74. (define (simplify-non-exit-args node)
  75.   (walkcdr simplify (nthcdr (call-args node) (call-exits node))))
  76.  
  77. ;;; Simplify the exits of call-node NODE.  If the node does a test, propogate
  78. ;;; appropriate results of the test down the two arms.  This is a small (but
  79. ;;; helpful) bit of type inferencing.
  80.  
  81. (define (simplify-exit-args node)
  82.   (cond ((fx= 1 (call-exits node))
  83.          (simplify (call-args node)))
  84.         ((fx= 2 (call-exits node))
  85.          (add-to-value-table node 'true)
  86.          (simplify (call-args node))
  87.          (add-to-value-table node 'false)
  88.          (simplify (cdr (call-args node)))
  89.          (add-to-value-table node nil))
  90.         (else
  91.          nil)))
  92.  
  93. ;;; *VALUE-TABLE* is bound by MAKE-CODE-TREE+SHAPE
  94.  
  95. (lset *value-table* (make-table '*value-table*))
  96.  
  97. (define (add-to-value-table call value)
  98.   (destructure (((#f #f test arg1 arg2) (call-args call)))
  99.     (cond ((and (primop-ref? test primop/test)
  100.                 (primop-ref? arg1 primop/true?)
  101.                 (reference-node? arg2))
  102.            (set (table-entry *value-table* (reference-variable arg2))
  103.                 value))
  104.           (else
  105.            nil))))
  106.  
  107. ;;; Calls to literals are flushed.
  108. ;;; Primops are simplified using their own methods.
  109. ;;; Calls to objects are simplified (the handler is flushed).
  110. ;;; If the second argument is a reference to a known object operation dispatch
  111. ;;;   will be attempted.
  112.  
  113. (define (simplify-call-using-proc proc node)
  114.   (cond ((object-node? proc)
  115.          (replace proc (detach (object-proc proc)))
  116.          t)
  117.         ((or (not (leaf-node? proc))
  118.              (literal-node? proc))
  119.          nil)
  120.         ((known-primop proc)
  121.          => (lambda (primop)
  122.               (primop.simplify primop node)))
  123. ;;      ((and (bound-to-operation? (call-proc node))
  124. ;;            (cdr (call-args node))
  125. ;;            (bound-to-object? ((call-arg 2) node)))
  126. ;;       (simplify-operation-dispatch node obj-exp))
  127.         (else
  128.          nil)))
  129.  
  130. ;;; Remove a call that has no side effects and produces no useful result.
  131.  
  132. (define (flush-unused-call node)
  133.   (cond ((and (not (side-effects? (call-proc node)))
  134.               (unused-call? node))
  135.          (replace node (detach (lambda-body ((call-arg 1) node))))
  136.          t)
  137.         (else
  138.          nil)))
  139.  
  140. (define (unused-call? node)
  141.   (and (fx= 1 (call-exits node))
  142.        (leaf-node? (call-proc node))
  143.        (lambda-node? ((call-arg 1) node))
  144.        (every? (lambda (var)
  145.                  (or (not var)
  146.                      (null? (variable-refs var))))
  147.                (lambda-rest+variables ((call-arg 1) node)))))
  148.  
  149. (define (side-effects? proc)
  150.   (cond ((known-primop proc)
  151.          => primop.side-effects?)
  152.         (else
  153.          t)))
  154.  
  155. ;;; OBJ is an object-lambda.  The methods are searched to see if there is
  156. ;;; one corresponding to the procedure being called.  If so, the method is
  157. ;;; substituted in-line.
  158.  
  159. (define (simplify-operation-dispatch call obj def)
  160.   (destructure (((#f op? proc ops methods) obj))
  161.     (ignore op? proc)
  162.     (let ((op-def (variable-definition (reference-variable (call-proc call))))
  163.           (env (definition-env def)))
  164.       (iterate loop ((ops ops) (methods methods))
  165.         (cond ((null? ops)
  166.                nil)
  167.               ((let ((var (vector->variable (car ops) env)))
  168.                  (and (variable? var)
  169.                       (eq? op-def (variable-definition var))))
  170.                (replace-operation-with-method call (car methods) def))
  171.               (else
  172.                (loop (cdr ops) (cdr methods))))))))
  173.  
  174. ;;;  (<op> <cont> <object> . <args>)
  175. ;;;   => (<method> <cont> <object>  . <args>)
  176. ;;; where <method> is <object>'s method for <op>.
  177.  
  178. (define (replace-operation-with-method call method def)
  179.   (let ((new (create-call-node (fx+ 1 (length (call-args call))) 1)))
  180.     (mark-reference-used (call-proc call))
  181.     (mark-reference-used ((call-arg 2) call))
  182.     (relate call-proc new (vector->node method (definition-env def)))
  183.     (relate-call-args new `(,(detach ((call-arg 1) call))
  184.                             . ,(map detach (cdr (call-args call)))))
  185.     (replace call new)
  186.     t))
  187.  
  188.  
  189.